home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 11
/
Cream of the Crop 11-1.iso
/
comm
/
txtq130.zip
/
SRQ.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-01-26
|
7KB
|
215 lines
{$M 10240,0,655360} { 10k reserved for data }
{$N-,E- no math support needed}
{$X- function calls may not be discarded}
{$I- disable I/O checking (trap errors by checking IOResult)}
PROGRAM Convert_SPEED_savefiles_to_QWK;
USES
DOS,
TXTQ;
VAR
SavedExitProc: POINTER;
{===========================================================================}
PROCEDURE CustomExit; FAR;
{---- Always exit through here ----}
BEGIN
ExitProc := SavedExitProc;
cursorOn;
Cleanup;
IF (ExitCode > 0) THEN BEGIN
WriteLn;
WriteLn ('SRQ - Free DOS utility: Convert SPEED READ "save files" to QWK files.');
WriteLn (author);
WriteLn;
WriteLn ('Usage: SRQ <SPEED "save file(s)"> (DOS wildcards are permitted.)');
WriteLn;
WriteLn ('Example: SRQ startrek.txt (creates "STARTREK.Q??")');
WriteLn;
END;
IF ErrorAddr <> NIL THEN
BEGIN
WriteLn ('An unanticipated error occurred, please contact DDA with the following data:');
WriteLn ('Address = ', Seg (ErrorAddr^), ':', Ofs (ErrorAddr^));
WriteLn ('Code = ', ExitCode);
ErrorAddr := NIL;
END
ELSE
IF (ExitCode > 0) AND (ExitCode < 255) THEN
WriteErr (ExitCode);
END;
FUNCTION GetMsgTime (timestr: STRING): STRING;
VAR
MsgTime: STRING [5];
hours: BYTE;
VErr: INTEGER;
BEGIN
MsgTime := Copy (timestr, 30, 5);
IF (Copy (timestr, 35, 1) = 'p') AND (Copy (MsgTime, 1, 2) <> '12') THEN BEGIN
Val (Copy (MsgTime, 1, 2), hours, VErr);
Inc (hours, 12);
MsgTime := LeadingZero (hours) + Copy (MsgTime, 3, 3);
END;
GetMsgTime := MsgTime;
END;
FUNCTION GetMsgStat (Status: CHAR): CHAR;
BEGIN
IF (Status = 'u')
THEN GetMsgStat := #32 { unread, public }
ELSE GetMsgStat := #42 { unread, private }
END;
FUNCTION ReadMsgHeader (VAR Msgfile: FILE): STRING;
CONST
hyphens = '---------------------------------------' +
'----------------------------------------';
Msgpass = #32#32#32#32#32#32#32#32#32#32#32#32; { 12 spaces }
Msgchnk = #32#32#32#32#32#32; { 6 spaces }
VAR
Msgline: STRING;
Msgfrom, Msgto, Msgsubj: STRING [25];
Msgdate: STRING [8]; Msgtime: STRING [5];
Msgnumb: STRING [7]; Msgrfer: STRING [8];
ConfNum: STRING [5]; MsgStat: CHAR;
Count: BYTE;
BEGIN
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
Verify (Msgline, 'Date:', 6); Msgdate := Copy (Msgline, 12, 8);
Verify (Msgline, 'Time:', 24); MsgTime := GetMsgTime (Msgline);
Verify (Msgline, 'Number:',41); Msgnumb := RPad (Copy (Msgline, 49, Length (Msgline) - 48), 7, #32);
for count := 1 to 2 do begin
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
if Copy (MsgLine, 6, 5) = 'From:' then
Msgfrom := Copy (Msgline, 12, 25)
else
if Copy (MsgLine, 8, 3) = 'To:' then
Msgto := Copy (Msgline, 12, 25);
if count = 1 then begin
Verify (Msgline, 'Refer:', 42);
Msgrfer := RPad (Copy (Msgline, 49, Length (Msgline) - 48), 8, #32);
end
else
if count = 2 then begin
(* Verify (Msgline, 'Recvd:', 65); MsgStat := Msgline[72]; <- SPEED v2.00 changed this *)
IF BBSname = '' THEN
BBSname := Trim (Copy (Msgline, 49, 15));
end;
end;
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
Verify (Msgline, 'Subject:', 3); Msgsubj := Copy (Msgline, 12, 25);
Verify (Msgline, ':', 47); ConfNum := StrToDoubleChar (Copy (Msgline, 42, 5));
Verify (Msgline, 'Status:', 64); MsgStat := GetMsgStat (Msgline [73]);
AddConfToList (ConfNum, Trim (Copy (Msgline, 49, 15)));
AddMsgToList (ConfNum, Blocks);
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb); {discard hyphen line}
Verify (Msgline, hyphens, 1);
ReadMsgheader := (MsgStat + Msgnumb + Msgdate+ MsgTime+ { 1+7+8+5 = 21 }
Msgto + Msgfrom + Msgsubj + { 25+25+25 = 75 }
Msgpass + Msgrfer + Msgchnk + #225 + { 12+8+6+1 = 27 }
ConfNum + #0#0#42); { 2+3 = 5 }
END;
{===========================================================================}
CONST
SepLine = '=======================================' +
'========================================';
VAR
Msgname: PATHSTR;
Msgext : EXTSTR;
Msgfile: FILE; DATfile : FILE;
Msgline: STRING; Message : MsgArray;
index, bytes, chunks: WORD;
Compressor : PATHSTR;
dirinfo : SEARCHREC; { contains filespec info. }
spath : PATHSTR; { source file path and }
sdir : DIRSTR; { directory }
filesdone : WORD;
BEGIN
SavedExitProc := ExitProc;
ExitProc := @CustomExit;
IF ParamCount <> 1
THEN Halt (255)
ELSE spath := GetFilePath (ParamStr (1), sDir);
FindFirst (spath, Archive, dirinfo);
filesdone := 0;
MkDir (TXTQ_DIR); CheckIO;
ChDir (TXTQ_DIR); CheckIO;
WHILE (DosError = 0) DO BEGIN
BBSname := '';
ConfList := NIL;
MsgList := NIL;
Conferences := 0;
Inc (filesdone);
Msgname := sdir + dirinfo. Name;
PrepareFiles (Msgname, Msgext, Msgfile, DATfile);
Blocks := 0;
Chunks := 2;
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
REPEAT
IF (NOT EoF (Msgfile)) AND (Msgline = SepLine) THEN BEGIN
bytes := 0; updateCursor;
Inc (Blocks, chunks);
Msgline := ReadMsgHeader (Msgfile);
WHILE (NOT EoF (Msgfile)) AND (Msgline <> SepLine) DO BEGIN
IF (bytes < MaxBytes) THEN
bytes := AddToArray (Message, bytes, Msgline);
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
END;
IF (bytes > MaxBytes) THEN bytes := MaxBytes;
WHILE (Message [bytes] = #227) AND (Message [bytes - 1] = #227) DO
Dec (bytes);
index := AddToArray (Message, 116, FigureMSGsize (bytes, chunks));
IF (chunks > 1) THEN BEGIN
FOR index := (bytes + 1) TO (chunks * 128) DO
Message [index] := #32;
END;
BlockWrite (DATfile, Message, chunks * 128); CheckIO;
END
ELSE BEGIN
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb); {discard invalid lines}
END;
UNTIL EoF (Msgfile);
Close (Msgfile); CheckIO;
Close (DATfile); CheckIO;
WriteLn ('done!');
InitConfig (Compressor);
Write ('Compressing ', DATname, ' into ', Msgname, Msgext, ' ... ');
IF CompressDat (Msgname + Msgext, Compressor)
THEN WriteLn ('done!')
ELSE Halt (5);
FindNext (dirinfo);
END;
IF (filesdone = 0)
THEN Halt (1)
ELSE WriteLn ('Processed ', filesdone, ' file(s).');
END.